home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / comp-class.scm < prev    next >
Text File  |  1992-09-05  |  17KB  |  490 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.  
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: comp-class.scm,v 1.9 1992/09/05 16:04:19 jmiller Exp $
  39.  
  40. ;;;; More of the compiler: class and binding related operations
  41. ;;;;
  42. ;;;; BIND, DEFINE-GENERIC-FUNCTION, DEFINE-CLASS, DEFINE-SLOT
  43.  
  44. ;;; Parsing and compiling BIND special forms
  45.  
  46. ;; Access functions for BINDings
  47.  
  48. (define (binding->names binding)
  49.   (let loop ((names '())
  50.          (rest binding))
  51.     (if (not (list? binding))
  52.     (dylan::error "bind -- bad binding" binding))
  53.     (if (or (null? rest) (null? (cdr rest)) (eq? '!rest (car rest)))
  54.     (reverse names)
  55.     (let ((this-binding (car rest)))
  56.       (cond ((variable-name? this-binding)
  57.          (loop (cons this-binding names)
  58.                (cdr rest)))
  59.         ((and (list-of-length? this-binding 2)
  60.               (variable-name? (car this-binding)))
  61.          (loop (cons (car this-binding) names)
  62.                (cdr rest)))
  63.         (else (dylan::error "bind -- bad binding list" binding)))))))
  64.  
  65. (define (binding->restrictions binding)
  66.   (let loop ((restrictions '())
  67.          (rest binding))
  68.     (if (or (null? rest) (null? (cdr rest)) (eq? '!rest (car rest)))
  69.     (reverse restrictions)
  70.     (let ((this-binding (car rest)))
  71.       (loop (cons
  72.          (if (variable-name? this-binding) #F (cadr this-binding))
  73.          restrictions)
  74.         (cdr rest))))))
  75.  
  76. (define (binding->rest binding)
  77.   (let ((found (memq '!rest binding)))
  78.     (if found
  79.     (begin
  80.       (must-be-list-of-length found 3
  81.         "bind -- error in bindings")
  82.       (cadr found))
  83.     #F)))
  84.  
  85. (define (binding->init binding)
  86.   (last binding))
  87.  
  88. (define (build-BIND-form bound-names rest-name compiled-restrictions
  89.              compiled-init compiled-body)
  90.   (let ((all
  91.        ;; Build a list with entries (offset name restriction)
  92.        ;; where 'offset' is offset in values vector,
  93.        (let process ((offset 0)
  94.              (names bound-names)
  95.              (restrictions compiled-restrictions))
  96.          (if (null? names)
  97.          '()
  98.          `((,offset ,(car names) ,(car restrictions))
  99.            ,@(process (+ offset 1) (cdr names) (cdr restrictions))))))
  100.       (->offset car)
  101.       (->name cadr)
  102.       (->restriction caddr))
  103.       (define restricted
  104.     (let loop ((rest all))
  105.       (if (null? rest)
  106.           '()
  107.           `(,@(if (->restriction (car rest)) (list (car rest)) `())
  108.         ,@(loop (cdr rest))))))
  109.       `(LET ((!BIND-BODY
  110.           (LAMBDA (,@bound-names ,@(if rest-name (list rest-name) `()))
  111.         ,compiled-body))
  112.          (!BIND-INIT-FORM
  113.           (LAMBDA (!MULTI-VALUE) ,compiled-init))
  114.          ,@(map (lambda (restriction)
  115.               `(,(->name restriction) ,(->restriction restriction)))
  116.             restricted))
  117.      (LET* ((!MULTI-VALUE
  118.          (DYLAN::VECTOR
  119.           ,@(map (lambda (name) name #F) bound-names)
  120.           `())) 
  121.         (!FIRST-VALUE (!BIND-INIT-FORM !MULTI-VALUE)))
  122.        (IF (DYLAN::EQ? !FIRST-VALUE !MULTI-VALUE)
  123.            ;; We went through values ...
  124.            ,(let ((call
  125.               `(!BIND-BODY
  126.             ,@(map (lambda (offset)
  127.                  `(DYLAN::VECTOR-REF !MULTI-VALUE ,offset))
  128.                    (map ->offset all))
  129.             ,@(if rest-name
  130.                   `((DYLAN::VECTOR-REF !MULTI-VALUE
  131.                            ,(length bound-names))) 
  132.                   `()))))
  133.          (if (null? restricted)
  134.              call
  135.              `(BEGIN
  136.             ,@(map (lambda (offset name)
  137.                  `(DYLAN::TYPE-CHECK
  138.                    (DYLAN::VECTOR-REF !MULTI-VALUE ,offset)
  139.                    ,name))
  140.                    (map ->offset restricted)
  141.                    (map ->name restricted))
  142.             ,call)))
  143.            ;; Didn't go through values ...
  144.            ,(if (null? bound-names)
  145.             `(!BIND-BODY (DYLAN::LIST !FIRST-VALUE))
  146.             (let* ((first (car all))
  147.                (restriction (->restriction first)))
  148.               (define call
  149.             `(!BIND-BODY !FIRST-VALUE
  150.                   ,@(map (lambda (name) name #F)
  151.                      (cdr bound-names))
  152.                   ,@(if rest-name `('()) `())))
  153.               (if restriction
  154.               `(BEGIN
  155.                  (DYLAN::TYPE-CHECK !FIRST-VALUE ,(->name first))
  156.                  ,call)
  157.               call))))))))
  158.  
  159. ;; Compiling the BIND form
  160.  
  161. (define (compile-BIND-form
  162.      e module-vars bound-vars really-compile
  163.      multiple-values? continue)
  164.   (must-be-list-of-at-least-length e 1 "BIND form invalid")
  165.   (let ((bindings (car e))
  166.     (forms (cdr e)))
  167.     (if (null? bindings)
  168.     (if (null? forms)
  169.         (continue compiled-sharp-f bound-vars)
  170.         (really-compile
  171.          `(BEGIN ,@forms)
  172.          module-vars bound-vars multiple-values? continue))
  173.     (begin
  174.       (if (not (list? bindings))
  175.           (dylan::error "bind -- bad bindings" bindings))
  176.       (let* ((binding (car bindings))
  177.          (bound-names (binding->names binding))
  178.          (rest-name (binding->rest binding))
  179.          (init-form (binding->init binding)))
  180.         (if (and (null? bound-names) (not rest-name))
  181.         (dylan::error "bind -- no variables bound" e))
  182.         (validate-names (if rest-name
  183.                 (cons rest-name bound-names)
  184.                 bound-names))
  185.         (compile-forms
  186.          (binding->restrictions binding)
  187.          module-vars bound-vars really-compile #F
  188.          (lambda (compiled-restrictions mod-vars)
  189.            (really-compile
  190.         init-form mod-vars bound-vars
  191.         (if (or rest-name
  192.             (and (not (null? bound-names))
  193.                  (not (null? (cdr bound-names)))))
  194.             '!MULTI-VALUE
  195.             #F)
  196.         (lambda (compiled-init new-mods)
  197.           (let ((bound-names (map variable->name bound-names))
  198.             (rest-name (and rest-name
  199.                     (variable->name rest-name))))
  200.             (really-compile
  201.              `(BIND ,(cdr bindings) ,@forms)
  202.              new-mods (append (if rest-name (list rest-name) '())
  203.                       bound-names
  204.                       bound-vars)
  205.              multiple-values?
  206.              (lambda (compiled-body new-mods)
  207.                (continue
  208.             (build-BIND-form bound-names rest-name
  209.                      compiled-restrictions compiled-init
  210.                      compiled-body)
  211.             new-mods)))))))))))))
  212.  
  213. ;;; Parsing and compiling the DEFINE-GENERIC-FUNCTION special form
  214.  
  215. (define (gen-fn-param-error params where)
  216.   (dylan::error "define-generic-function -- parameter syntax error"
  217.         params where))
  218.  
  219. (define (parse-gen-fn-params orig-params allowed-fn continue)
  220.   (let loop ((names '())
  221.          (params orig-params))
  222.     (cond ((null? params) (continue (reverse names) params))
  223.       ((not (pair? params))
  224.        (gen-fn-param-error orig-params (list 'PARSING params)))
  225.       ((allowed-fn (car params)) =>
  226.        (lambda (value)
  227.          (loop (cons value names) (cdr params))))
  228.       (else (continue (reverse names) params)))))
  229.  
  230. (define (parse-DEFINE-GENERIC-FUNCTION
  231.      name params keywords compiler)
  232.   keywords                ; Not used
  233.   (if (not (variable-name? name))
  234.       (dylan::error "define-generic-function -- illegal name" name))
  235.   (parse-gen-fn-params
  236.    params (lambda (x) (and (variable-name? x) x)) 
  237.    (lambda (reqs rest)
  238.      (define (symbol-or-keyword x)
  239.        (cond ((memq x '(!KEY !REST)) x)
  240.          ((dylan-special-name? x)
  241.           (gen-fn-param-error params (list 'RESERVED-NAME rest)))
  242.          ((keyword? x) x)
  243.          ((symbol? x) (name->keyword x))
  244.          (else #F)))
  245.      (define (compile-keys rest)
  246.        (lambda (keys after-keys)
  247.      (if (not (null? after-keys))
  248.          (gen-fn-param-error params (list 'COMPILE-KEYS after-keys)))
  249.      (compiler name reqs rest keys)))
  250.      (cond ((null? rest) (compiler name reqs #F #F))
  251.        ((not (pair? rest))
  252.         (gen-fn-param-error params (list 'STRANGE-REST rest)))
  253.        (else
  254.         (case (car rest)
  255.           ((!REST)
  256.            (let ((after-rest (cdr rest)))
  257.          (if (or (not (pair? after-rest))
  258.              (not (variable-name? (car after-rest))))
  259.              (gen-fn-param-error
  260.               params
  261.               (list 'POST-!REST after-rest)))
  262.          (let ((rest (car after-rest)))
  263.            (cond ((null? (cdr after-rest))
  264.               (compiler name reqs rest #F))
  265.              ((not (pair? (cdr after-rest)))
  266.               (gen-fn-param-error
  267.                params
  268.                (list 'AFTER-!REST (cdr after-rest))))
  269.              ((eq? `!KEY (cadr after-rest))
  270.               (parse-gen-fn-params
  271.                (cddr after-rest) symbol-or-keyword
  272.                (compile-keys rest)))
  273.              (else
  274.               (gen-fn-param-error
  275.                params
  276.                (list 'BEFORE-!KEY (cddr after-rest))))))))
  277.           ((!KEY)
  278.            (if (null? (cdr rest))
  279.            (compiler name reqs #F #T)
  280.            (parse-gen-fn-params
  281.             (cdr rest) symbol-or-keyword
  282.             (compile-keys #F))))
  283.           (else (gen-fn-param-error
  284.              params
  285.              (list 'UNKNOWN-STOPPER rest)))))))))
  286.  
  287. (define (compile-DEFINE-GENERIC-FUNCTION-form
  288.      e mod-vars bound-vars compiler multiple-values? continue)
  289.   compiler                ; No sub-compilations
  290.   multiple-values?            ; No reductions
  291.   (must-be-list-of-length e 2
  292.     "DEFINE-GENERIC-FUNCTION: invalid syntax")
  293.   (parse-DEFINE-GENERIC-FUNCTION (car e) (cadr e) (cddr e)
  294.    (lambda (name reqs rest keys)
  295.      (module-refs
  296.       name bound-vars mod-vars
  297.       continue
  298.       (lambda (ref set)
  299.     `(IF (DYLAN::NOT (OR (DYLAN::EQ? ,ref ',the-unassigned-value)
  300.                  (DYLAN::GENERIC-FUNCTION? ,ref)))
  301.          (DYLAN-CALL DYLAN:ERROR
  302.              "define-generic-function -- already has a value"
  303.              ',name ,ref ',reqs ',rest ',keys)
  304.          (BEGIN
  305.            ,(set `(DYLAN::CREATE-GENERIC-FUNCTION
  306.                ',name ,(length reqs) ',keys ,(if rest #T #F)))
  307.            ',name)))))))
  308.  
  309. ;;; Parsing and compiling the DEFINE-CLASS form
  310.  
  311. (define (expand-slot slot)
  312.   (define (build-slot pairs default-getter)
  313.     (validate-keywords
  314.      pairs
  315.      '(getter: setter: type: init-value: init-function: init-keyword:
  316.            required-init-keyword: allocation:)
  317.      dylan::error)
  318.     (let ((getter
  319.        (dylan::find-keyword pairs 'getter:
  320.                 (lambda ()
  321.                   (or default-getter
  322.                       (dylan::error
  323.                        "slot expander -- no getter name"
  324.                        pairs)))))
  325.       (setter
  326.        (dylan::find-keyword
  327.         pairs 'setter: (lambda ()
  328.                  (if default-getter
  329.                  `(SETTER ,default-getter)
  330.                  #F))))
  331.       (type
  332.        (dylan::find-keyword pairs 'type: (lambda () '<object>)))
  333.       (has-initial-value? #T))
  334.       (let ((init-value
  335.          (dylan::find-keyword pairs 'init-value:
  336.                   (lambda ()
  337.                     (set! has-initial-value? #F)
  338.                     #F)))
  339.         (init-function
  340.          (dylan::find-keyword pairs 'init-function: (lambda () #F)))
  341.         (init-keyword
  342.          (dylan::find-keyword pairs 'init-keyword: (lambda () #F)))
  343.         (required-init-keyword
  344.          (dylan::find-keyword pairs 'required-init-keyword:
  345.                   (lambda () #F)))
  346.         (allocation
  347.          (dylan::find-keyword pairs 'allocation: (lambda () 'instance))))
  348.     (if (and (variable-name? getter)
  349.          (or (not setter) (variable-name? setter))
  350.          (or (not has-initial-value?) (not init-function))
  351.          (or (not required-init-keyword)
  352.              (and (not init-keyword) (not has-initial-value?)
  353.               (not init-function)))
  354.          (memq allocation '(instance class each-subclass
  355.                          constant virtual)))
  356.         (make-slot getter        ; debug-name
  357.                getter setter type init-value has-initial-value?
  358.                init-function init-keyword required-init-keyword
  359.                allocation #F #F)
  360.         (dylan::error "slot expander -- bad slot"
  361.               getter setter has-initial-value? init-value
  362.               init-function init-keyword
  363.               required-init-keyword allocation)))))
  364.   (cond ((symbol? slot)
  365.      (make-slot slot slot `(SETTER ,slot) '<object> #F #F #F #F #F
  366.             'instance #F #F))
  367.     ((and (pair? slot) (keyword? (car slot)))
  368.      (build-slot slot #F))
  369.     ((and (pair? slot) (symbol? (car slot))
  370.           (variable-name? (car slot)))
  371.      (build-slot (cdr slot) (car slot)))
  372.     (else (dylan::error "slot expander -- bad slot specification"
  373.                 slot))))
  374.  
  375. (define (expand-slots slots)
  376.   (map expand-slot slots))
  377.  
  378. (define (make-add-slot-call
  379.      slot owner bound-vars mod-vars compiler continue)
  380.   (define (get-mod-var name mod-vars setter? continue)
  381.     (if name
  382.     (module-refs name bound-vars mod-vars continue 
  383.       (lambda (ref set)
  384.         `(BEGIN
  385.            (COND ((DYLAN::EQ? ,ref ',the-unassigned-value)
  386.               ,(set `(DYLAN::CREATE-GENERIC-FUNCTION
  387.                   ',(variable->name name)
  388.                   ,(if setter? 2 1) ; # of arguments
  389.                   #F    ; No required keywords
  390.                   #F)))    ; No rest argument
  391.              ((DYLAN::NOT (DYLAN::GENERIC-FUNCTION? ,ref))
  392.               (DYLAN-CALL DYLAN:ERROR
  393.                   "Slot function -- already has a value"
  394.                   ',(slot.debug-name slot) ,owner)))
  395.            ,ref)))
  396.     (continue #F mod-vars)))
  397.   (get-mod-var (slot.getter slot) mod-vars #F
  398.     (lambda (getter mv)
  399.       (get-mod-var (slot.setter slot) mv #T
  400.     (lambda (setter mv)
  401.       (compile-forms
  402.        (list (slot.type slot)
  403.          (slot.init-value slot)
  404.          (slot.init-function slot))
  405.        mv bound-vars compiler #F
  406.        (lambda (compiled-forms mv)
  407.          (continue
  408.           `(DYLAN::ADD-SLOT ,owner
  409.                 ,(car compiled-forms) ; Type
  410.                 ',(slot.allocation slot)
  411.                 ,setter
  412.                 ,getter
  413.                 ',(slot.debug-name slot)
  414.                 ,(cadr compiled-forms) ; Init-Value
  415.                 ,(slot.has-initial-value? slot)
  416.                 ,(caddr compiled-forms) ; Init-Function
  417.                 ',(slot.init-keyword slot)
  418.                 ',(slot.required-init-keyword slot))
  419.           mv))))))))
  420.  
  421. (define (generate-DEFINE-CLASS
  422.      name superclasses getter-code slots bound-vars
  423.      mod-vars compiler continue)
  424.   (let loop ((slots slots)
  425.          (mod-vars mod-vars)
  426.          (add-slot-calls '()))
  427.     (if (null? slots)
  428.     (module-refs name bound-vars mod-vars continue
  429.       (lambda (ref set)
  430.         set                ; Ignored
  431.         `(BEGIN
  432.            (IF (DYLAN::NOT
  433.             (OR (DYLAN::EQ? ,ref ',the-unassigned-value)
  434.             (DYLAN::CLASS? ,ref)))
  435.            (DYLAN-CALL DYLAN:ERROR
  436.                    "define-class -- already has a value"
  437.                    ',name ,ref ',(map slot.getter slots))
  438.            (LET ((!CLASS
  439.               (DYLAN::MAKE-A-CLASS
  440.                ',name
  441.                (DYLAN::LIST ,@superclasses)
  442.                (DYLAN::LIST ,@getter-code))))
  443.              ,@add-slot-calls
  444.              ,(set '!CLASS)
  445.              ',name)))))
  446.     (make-add-slot-call
  447.      (car slots) '!CLASS bound-vars mod-vars compiler
  448.      (lambda (code mod-vars)
  449.        (loop (cdr slots)
  450.          mod-vars
  451.          (cons code add-slot-calls)))))))
  452.  
  453. (define (compile-DEFINE-CLASS-form
  454.      e mod-vars bound-vars compiler multiple-values? continue)
  455.   multiple-values?            ; No reductions
  456.   (must-be-list-of-at-least-length e 2 "DEFINE-CLASS: invalid syntax")
  457.   (let ((superclasses (cadr e))
  458.     (slots (expand-slots (cddr e))))
  459.     (compile-forms superclasses mod-vars bound-vars compiler #F
  460.       (lambda (supers mod-vars)
  461.     (let loop ((getter-code '())
  462.            (slots-left slots)
  463.            (mod-vars mod-vars))
  464.       (if (null? slots-left)
  465.           (generate-DEFINE-CLASS
  466.            (car e) supers getter-code slots
  467.            bound-vars mod-vars compiler continue)
  468.           (module-refs (slot.getter (car slots))
  469.                bound-vars mod-vars
  470.                (lambda (code mod-vars)
  471.                  (loop (cons code getter-code)
  472.                    (cdr slots-left)
  473.                    mod-vars))
  474.                (lambda (ref set)
  475.                  set    ; Ignored
  476.                  ref))))))))
  477.  
  478. ;;; DEFINE-SLOT
  479.  
  480. (define (compile-DEFINE-SLOT-form
  481.      e mod-vars bound-vars compiler multiple-values? continue)
  482.   multiple-values?            ; Ignored
  483.   (must-be-list-of-at-least-length e 2 "DEFINE-SLOT: invalid syntax")
  484.   (let ((owner (car e))
  485.     (slot (cdr e)))
  486.     (make-add-slot-call
  487.      (expand-slot
  488.       (if (keyword? (car slot)) slot `(GETTER: ,@slot)))
  489.      owner bound-vars mod-vars compiler continue)))
  490.